home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
entrdata.zip
/
ENTRDATA.INC
< prev
next >
Wrap
Text File
|
1993-01-04
|
19KB
|
701 lines
{ entrdata.inc - Data entry procedures for entrdata.pas }
function InsertOn: boolean;
const InsertStateBit=$80; { Bit 7 }
var KeyStatus: byte absolute $0040:$0017;
begin
InsertOn := (KeyStatus and InsertStateBit)<>0;
end;
procedure ToggleNumLock (Switch: Toggle);
const
LastNumLockBit: byte = 0; { dummy assumption }
NumLockBit = $20; { bit 5 }
var KeyStatus: byte absolute $0000:$0417;
begin
if (TopEntry.TypeOfData<Strings) and AutoNumLock then
case Switch of
On: begin
LastNumLockBit := KeyStatus and NumLockBit;
KeyStatus := KeyStatus or NumLockBit;
end;
Off: KeyStatus := (KeyStatus and $DF) or LastNumLockBit;
end;
end;
procedure CallTranslate; { indirect }
inline ($FF/$1E/TopEntry+11);
{ call DWORD PTR [>TopEntry.TranslateProc] }
procedure CallCheckRange; { indirect }
inline ($FF/$1E/TopEntry+15);
{ call DWORD PTR [>TopEntry.CheckRangeProc] }
procedure CallErrHandler; { indirect } {Added [GAF]}
inline ($FF/$1E/DataPad+10);
{ call DWORD PTR [>DataPad.ErrHandlerProc] }
procedure TransferData (VAR UserVariable);
var
Size: byte;
StrLength: byte absolute UserVariable;
begin
with TopEntry,DataPad do
begin
case TypeOfData of
Bytes,Chars,ShortInts: Size:=1;
Words,Integers: Size:=2;
LongInts: Size:=4;
Reals: Size:=6;
else
if StoreMode then
Size := succ( MinI( ord(Sdata[0]),MaxField ))
else Size := succ(StrLength);
end;
if StoreMode then
Move16 (Bdata,UserVariable,Size)
else
begin
Ldata := 0; { Clear first }
Move16 (UserVariable,Bdata,Size);
end;
end
end;
procedure StripLeadingSpaces (Field: byte);
var
i: integer;
begin
if DataStrL>0 then
begin
i := 1;
while (DataStr[i]=' ') and (i<Field) do
inc(i);
DataStrL := succ(Field-i);
Move16 (DataStr[i],DataStr[1],DataStrL);
end;
end;
procedure ConvertDataToStr;
begin
with TopEntry,DataPad do
begin
StoreMode := false;
TransferData (VarAddr^);
case TypeOfData of
Bytes..Words,LongInts: DataStr := StrL (Ldata);
ShortInts: DataStr := StrL (SIdata);
Integers: DataStr := StrL (Idata);
Reals:
begin
if Decimals<0 then
DataStr := StrRF (Rdata,Field)
else
begin
DataStr := StrRFD (Rdata,Field,Decimals);
if DataStrL>Field then
DataStr := StrRF (Rdata,Field);
end;
StripLeadingSpaces (Field);
end;
Chars: DataStr := Cdata;
else DataStr := Sdata;
end; { case }
end; { with }
end;
procedure ConvertStrToData;
var i: integer;
begin
with TopEntry,DataPad do
begin
Valid := true;
case TypeOfData of
Chars: if DataStrL=0 then
Cdata := #00
else Cdata := DataStr[1];
Reals: begin
val (DataStr,Rdata,i);
Valid := i=0;
end;
Bytes..LongInts:
begin
val (DataStr,Ldata,i);
Valid := i=0;
if Valid then
case TypeOfData of
Bytes: Valid := Ldata=Bdata;
Words: Valid := Ldata=Wdata;
ShortInts: Valid := Ldata=SIdata;
Integers: Valid := Ldata=Idata;
end;
end;
else Sdata:=DataStr;
end; { case }
if not Valid then {Added [GAF]}
begin
if ErrHandlerProc<>nil then
CallErrHandler;
ExtKey:=false; {Set keys to force edit to stay here}
Key:=NullKey;
end;
{$ifdef UseMsgLineCode } {HERE - hook for invalid entry}
if not Valid then
ShowErrMsg (ord(InvalidEM)); { Invalid Entry message }
{$endif }
end;
end;
procedure StoreData;
begin
with TopEntry,DataPad do
if Valid then
begin
RangeOK := true;
if CheckRangeProc<>nil then
CallCheckRange;
DataStored := RangeOK; { OK to set in advance }
if DataStored then
begin
StoreMode := true;
TransferData (VarAddr^);
end
else
Key:=NullKey; {To stay in data entry}
end
end;
procedure UpdateField (Attr: integer);
var
FieldStr,SubStr: string;
L: byte absolute SubStr;
begin
with TopEntry,DataPad,TWS do
begin
SubStr := copy (DataStr,FieldIndex,Field);
if Justify=Left then
FieldStr := StrSL (SubStr,Field) { Fill up blanks w/ spaces }
else FieldStr := StrSR (SubStr,Field);
if DataWriteMode=ScrnRel then
Qwrite (Row,Col,Attr,FieldStr)
else
Qwrite (pred(Wrow+Row),pred(Wcol+Col),Attr,FieldStr);
end;
end;
procedure MoveCursor;
begin
with TopEntry,DataPad do
begin
if DataWriteMode=ScrnRel then
GotoRC (Row,Col+CursorOfs)
else
WGotoRC (Row,Col+CursorOfs);
if InsertOn then
SetCursor (CursorHalfBlock)
else SetCursor (CursorUnderline);
end;
end;
function MaxCursorOfs: byte;
begin
with TopEntry,DataPad do
MaxCursorOfs := MinI (DataStrL,Field-Flex);
end;
function MaxFieldIndex: byte;
begin
with TopEntry,DataPad do
MaxFieldIndex := MaxI (1,succ(DataStrL-Field+Flex));
end;
procedure CursorFirst;
begin
with DataPad do
begin
FieldIndex := 1;
CursorOfs := 0;
end;
end;
procedure CursorLast;
begin
with TopEntry,DataPad do
if MaxField>1 then
begin
Flex := byte(MaxField<>Field);
FieldIndex := MaxFieldIndex;
CursorOfs := MaxCursorOfs;
end
else CursorFirst;
end;
procedure CursorLeft;
begin
with DataPad do
begin
if CursorOfs=0 then
FieldIndex := MaxI (1,pred(FieldIndex))
else dec(CursorOfs);
end;
end;
procedure CursorRight;
begin
with TopEntry,DataPad do
if MaxField>1 then
begin
if CursorOfs=MaxCursorOfs then
FieldIndex := MinI (succ(FieldIndex),MaxFieldIndex)
else inc(CursorOfs);
end;
end;
procedure DeleteChar;
begin
with DataPad do
Delete (DataStr,FieldIndex+CursorOfs,1);
end;
procedure BackSpace;
begin
with TopEntry,DataPad do
begin
if (FieldIndex+CursorOfs>1) or (MaxField=1) then
begin
CursorLeft;
DeleteChar;
if (FieldIndex>1) and (CursorOfs=0) then
begin
CursorLeft;
CursorRight;
end;
end;
end;
end;
procedure ClrDataStr;
begin
DataStr := '';
CursorFirst;
end;
procedure ToggleInsert;
const InsertBit = $80;
var KeyStatus: byte absolute $0040:$0017;
begin
KeyStatus := KeyStatus xor InsertBit;
end;
procedure AddChar;
var DI: integer; { DataStr Index }
begin
with TopEntry,DataPad do
begin
if MaxField=1 then
DataStr := Key { Just overwrite the charcter }
else
begin
if NewData then
ClrDataStr;
DI := FieldIndex+CursorOfs;
if not InsertOn and (DI<=DataStrL) then
begin
DataStr[DI] := Key;
CursorRight;
end
else
if (DataStrL<MaxField) and (InsertOn or (DI>DataStrL)) then
begin
insert (Key,DataStr,DI);
CursorRight;
end;
end;
end;
end;
procedure ExtKeyEdit;
begin
with TopEntry,DataPad do
begin
case Key of
LArrKey: CursorLeft;
RArrKey: CursorRight;
DelKey: DeleteChar;
HomeKey,CtrlLArrKey: CursorFirst;
EndKey,CtrlRArrKey: CursorLast;
InsKey: ;
{$ifdef UseHelpWndwCode } {Future help window call here}
{HelpKey: PullHelpWndw (HelpWndwNum);}
{$endif }
{else CallCheckGlobalKeys;} {future global key handler call}
end { end case }
end;
end;
procedure NormKeyEdit;
var DI: integer; { DataStr Index }
begin
with TopEntry,DataPad do
begin
if (Key in EntrySet[SetName]) then
AddChar
else
begin
case Key of
^S: CursorLeft;
^D: CursorRight;
^G: DeleteChar;
^H,BSkey: BackSpace;
^A: CursorFirst;
^F: CursorLast;
^Y: ClrDataStr;
^R,^U:
begin
ConvertDataToStr;
CursorLast;
end;
^V: ToggleInsert;
end { end case }
end;
end; { with }
end;
procedure DisplayField (Attr: integer);
begin
with TopEntry,DataPad do
begin
ConvertDataToStr;
Justify := JustifyOutput;
if Justify=Left then
FieldIndex := 1
else FieldIndex := MaxI (1,succ(DataStrL-Field));
if Attr=SameAttr then
Attr := Oattr;
UpdateField (Attr);
end;
end;
procedure GetDataEntryRec (Index: word);
begin
DEI := Index;
TopEntry := DataEntry^[DEI];
end;
procedure DisplayFields; { (DEGroup : DEGroupRec; First,Last: byte); }
var
i: integer;
begin
if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
runerror(204);
DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
for i:=First to Last do
begin
GetDataEntryRec (i);
DisplayField (TopEntry.Oattr);
end;
end;
procedure SaveData;
begin
ConvertStrToData;
StoreData;
end;
procedure EnterData;
begin
with TopEntry,DataPad do
begin
ToggleNumLock (On);
ConvertDataToStr;
CursorLast;
Justify := Left;
repeat
if WaitForKbd then
begin
UpdateField (Iattr);
MoveCursor;
end;
if not WaitForKbd then
WaitForKbd:=true
else
ReadKbd(ExtKey,Key); {[GAF]}
if TranslateProc<>nil then
CallTranslate;
if ExtKey then
ExtKeyEdit
else NormKeyEdit;
NewData := false;
if (Key=RetKey) then { RetKey will even apply from Help window }
SaveData;
until (Key=RetKey) or (Key=EscKey) ;
ToggleNumLock (Off);
end; { with TopEntry }
end;
procedure Enter; { (DEGroup : DEGroupRec; RecNum: word); }
var
OldCursor: word;
begin
OldCursor := GetCursor;
if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
runerror(204);
DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
with TopEntry,DataPad do
begin
GetDataEntryRec (RecNum);
if VarAddr = nil then {cause error and halt if nil pointer}
runerror(204);
NewData := true;
EnterData;
DisplayField (Oattr);
end;
SetCursor (OldCursor);
end;
procedure MoveCursorToField;
begin
with TopEntry,DataPad,TWS do
begin
CursorOfs:=0;
if DataWriteMode=ScrnRel then
Qattr (Row,Col,1,Field,Hattr)
else
Qattr (pred(Wrow+Row),pred(Wcol+Col),1,Field,Hattr);
MoveCursor;
end;
end;
function RollInc (First,NumToRoll,Last: word): word;
begin
if NumToRoll=Last then
RollInc:=First
else RollInc:=succ(NumToRoll);
end;
function RollDec (First,NumToRoll,Last: word): word;
begin
if NumToRoll=First then
RollDec:=Last
else RollDec:=pred(NumToRoll);
end;
procedure EnterSeq; { (DEGroup : DEGroupRec; First,Last: word; VAR Start: word); }
var
Edit: boolean;
Attr: integer;
{}procedure HorizAdj (AdjacentCol,NearestCol: byte);
var i: word;
begin
for i:=First to Last do
with DataEntry^[i] do
if (Row=TopEntry.Row) and
InRangeW(AdjacentCol,Col,NearestCol) then
begin
Start := i;
NearestCol := Col;
end;
{}end;
{}procedure HorizEnd (Dir: DirType);
var
i: word;
FarCol: byte;
begin
FarCol := TopEntry.Col;
for i:=First to Last do
with DataEntry^[i] do
if (Row=TopEntry.Row) then
if ((Dir=Right) and (Col>FarCol)) or
((Dir=Left ) and (Col<FarCol)) then
begin
Start := i;
FarCol := Col;
end;
{}end;
{}procedure VertAdj (AdjacentRow,NearestRow: byte);
var
i: word;
NearestCols: byte;
Cols: integer;
Closer: boolean;
begin
NearestCols := 255;
for i:=First to Last do
with DataEntry^[i] do
begin
Cols := Col-TopEntry.Col;
if Cols<0 then
Cols := abs( MinI(Cols+Field,0) );
if (Row=NearestRow) then
Closer := Cols<NearestCols
else Closer := InRangeW (AdjacentRow,Row,NearestRow);
if Closer then
begin
Start := i;
NearestRow := Row;
NearestCols := Cols;
end;
end;
{}end;
{}procedure NextField;
begin
Start := RollInc (First,Start,Last);
{}end;
var
OldCursor: word;
begin
OldCursor := GetCursor;
if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
runerror(204);
DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
with TopEntry,DataPad do
begin
repeat
GetDataEntryRec (Start);
if VarAddr = nil then {cause error and halt if nil pointer}
runerror(204); {Didn't assign this entry}
MoveCursorToField;
if not WaitForKbd then
WaitForKbd:=true
else
ReadKbd(ExtKey,Key); {[GAF]}
Edit := false;
if ExtKey then
case Key of
UpArrKey: VertAdj (pred(TopEntry.Row), 0);{ Prev row }
DnArrKey: VertAdj (succ(TopEntry.Row),255);{ Next row }
LArrKey: HorizAdj (pred(TopEntry.Col), 0);{ Prev col }
RArrKey: HorizAdj (succ(TopEntry.Col),255);{ Next col }
CtrlLArrKey,HomeKey: HorizEnd (Left); { First char }
CtrlRArrKey,EndKey: HorizEnd (Right); { Last char }
CtrlHomeKey,PgUpKey: Start := First;
CtrlEndKey,PgDnKey: Start := Last;
ShiftTabKey: Start := RollDec (First,Start,Last);
InsKey: ;
{$ifdef UseHelpWndwCode }
{HelpKey: PullHelpWndw (1);} {future help here}
{$endif }
{else CallCheckGlobalKeys;} {future global key handler here}
end
else
case Key Of
RetKey: Edit := true;
TabKey: NextField;
EscKey: ; { Exit sequence }
^V: ToggleInsert;
else
Edit := true;
WaitForKbd := false;
end;
if Edit then
begin
NewData := Key<>RetKey;
EnterData;
if (Key=RetKey) and AutoTab then
NextField;
case Key of
RetKey,EscKey:
if (Start=DEI) then
DisplayField (Hattr);
end;
if Key=EscKey
then Key := #00;
end;
if Start<>DEI then
DisplayField (Oattr);
until (Key=EscKey) or (ExtKey and (Key=SeqDoneKey));
DisplayField (Oattr);
end; { with }
SetCursor (OldCursor);
end;
function GetJustify (Justify: DirType; TOD: TypeOfDataType): DirType;
begin
if Justify=NoDir then
begin
if TOD<=UserNums then
GetJustify := Right { for nums }
else GetJustify := Left; { for chars and strings }
end
else GetJustify:=Justify;
end;
function GetSetName (SN: SetNames; TOD: TypeOfDataType): SetNames;
begin
if SN=NoSet then
case TOD of
Bytes,Words: GetSetName := UnsignedSet;
ShortInts..LongInts: GetSetName := SignedSet;
Reals: GetSetName := RealSet;
else
GetSetName := CharSet;
end
else GetSetName:=SN;
end;
procedure GetDataEntry; { (DEGroup : DEGroupRec; Index: word); }
begin
if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
runerror(204);
DataEntry:=DEGroup.GroupPtr; {Point to proper DE group}
DEI := Index;
TopEntry := DataEntry^[DEI];
fillchar(TopEntry,sizeof(TopEntry),0); {clear it}
end;
procedure SaveDataEntry;
begin
with TopEntry do
begin
SetName := GetSetName (SetName,TypeOfData);
if MaxField=0 then
MaxField := Field;
JustifyOutput := GetJustify (JustifyOutput,TypeOfData);
if Iattr=0 then
Iattr := DataEntryIattr; { Default Input attribute }
if Oattr=0 then
Oattr := DataEntryOattr; { Output attribute }
end;
DataEntry^[DEI] := TopEntry;
end;
procedure AllocateDataEntries; {(var DEGroup : DEGroupRec; NumEntries : word);}
{Allocates memory for a group of data entries and assigns pointer to group rec}
var
size: word;
begin
Size:=sizeof(DataEntryRec)*NumEntries; {memory needed}
with DEGroup do
begin
if InRangeW(1,NumEntries,MaxDataEntries) and HeapOK(Size) then
begin
getmem(GroupPtr,Size);
NumInGroup:=NumEntries;
fillchar(GroupPtr^,Size,0);
end
else
begin
GroupPtr:=nil; {range or other error}
NumInGroup:=0;
end;
end; {with}
end;
procedure RemoveDataEntries; {(var DEGroup : DEGroupRec);}
{De-allocates DE recs created w/ Create}
begin
if DEGroup.GroupPtr = nil then {cause error and halt if nil pointer}
runerror(204);
with DEGroup do
begin
freemem(GroupPtr,sizeof(DataEntryRec)*NumInGroup);
GroupPtr:=nil; {Clear rec}
NumInGroup:=0;
end; {with}
end;